home *** CD-ROM | disk | FTP | other *** search
/ Programmer Plus 2007 / Programmer-Plus-2007.iso / Programming / Visual Basic new SourceCode and Projects / CD-Player / Marquee.ctl < prev    next >
Encoding:
Text File  |  1999-10-20  |  9.6 KB  |  374 lines
  1. VERSION 5.00
  2. Begin VB.UserControl AXMarquee 
  3.    Appearance      =   0  '2D
  4.    AutoRedraw      =   -1  'True
  5.    BackColor       =   &H8000000D&
  6.    ClientHeight    =   2730
  7.    ClientLeft      =   0
  8.    ClientTop       =   0
  9.    ClientWidth     =   4605
  10.    PropertyPages   =   "Marquee.ctx":0000
  11.    ScaleHeight     =   182
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   307
  14.    ToolboxBitmap   =   "Marquee.ctx":0011
  15.    Begin VB.PictureBox picBlankCol 
  16.       Appearance      =   0  '2D
  17.       AutoSize        =   -1  'True
  18.       BackColor       =   &H80000005&
  19.       BorderStyle     =   0  'Kein
  20.       ForeColor       =   &H80000008&
  21.       Height          =   690
  22.       Left            =   720
  23.       Picture         =   "Marquee.ctx":010B
  24.       ScaleHeight     =   46
  25.       ScaleMode       =   3  'Pixel
  26.       ScaleWidth      =   5
  27.       TabIndex        =   2
  28.       Top             =   600
  29.       Visible         =   0   'False
  30.       Width           =   75
  31.    End
  32.    Begin VB.PictureBox picCaps 
  33.       Appearance      =   0  '2D
  34.       AutoSize        =   -1  'True
  35.       BackColor       =   &H80000005&
  36.       BorderStyle     =   0  'Kein
  37.       ForeColor       =   &H80000008&
  38.       Height          =   540
  39.       Left            =   -2148
  40.       Picture         =   "Marquee.ctx":06BD
  41.       ScaleHeight     =   35.752
  42.       ScaleMode       =   0  'Benutzerdefiniert
  43.       ScaleWidth      =   889.6
  44.       TabIndex        =   1
  45.       Top             =   2130
  46.       Width           =   13350
  47.    End
  48.    Begin VB.PictureBox picMsg 
  49.       Appearance      =   0  '2D
  50.       AutoRedraw      =   -1  'True
  51.       BackColor       =   &H80000005&
  52.       BorderStyle     =   0  'Kein
  53.       ForeColor       =   &H80000008&
  54.       Height          =   540
  55.       Left            =   0
  56.       ScaleHeight     =   36
  57.       ScaleMode       =   3  'Pixel
  58.       ScaleWidth      =   78
  59.       TabIndex        =   0
  60.       Top             =   1485
  61.       Width           =   1170
  62.    End
  63.    Begin VB.Timer tAni 
  64.       Enabled         =   0   'False
  65.       Interval        =   50
  66.       Left            =   204
  67.       Top             =   156
  68.    End
  69. End
  70. Attribute VB_Name = "AXMarquee"
  71. Attribute VB_GlobalNameSpace = False
  72. Attribute VB_Creatable = True
  73. Attribute VB_PredeclaredId = False
  74. Attribute VB_Exposed = False
  75. Attribute VB_Description = "ActiveX Marquee Control"
  76. Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
  77. Option Explicit
  78.  
  79. Enum ScrollModeValue
  80.   R_to_L = 0
  81.   L_to_R = 1
  82. End Enum
  83.  
  84. 'Vars for tracking BMP size and position
  85. Private lBMPWidth   As Long     'Total width of the Message Bitmap to be drawn on the background
  86. Private bRestart    As Boolean
  87. Private lCtlWidth   As Long
  88. Const SRC_Y = 0
  89. Const CTL_HEIGHT = 683
  90. Const m_def_ScrollMode = R_to_L
  91. Const m_def_Text = "ActiveX Marquee"
  92. Const m_def_Scrolling = False
  93. Dim m_ScrollMode As ScrollModeValue
  94. Dim m_Text As String
  95. Dim m_Scrolling As Boolean
  96.  
  97. Private Sub tAni_Timer()
  98.   Static lX           As Long
  99.   Static lX2          As Long
  100.   Static lSrcOffset   As Long
  101.   Static lSrcWidth    As Long
  102.  
  103.   If bRestart Then
  104.     If m_ScrollMode = R_to_L Then
  105.       lX = lCtlWidth - BULB_WIDTH
  106.       lSrcOffset = 0
  107.       lSrcWidth = BULB_WIDTH
  108.     Else
  109.     
  110.       lX = BULB_WIDTH
  111.       lSrcOffset = BULB_WIDTH
  112.       lSrcWidth = BULB_WIDTH
  113.     End If
  114.  
  115.     bRestart = False
  116.   End If
  117.   
  118.   If m_ScrollMode = R_to_L Then
  119.     If lX > 0 Then
  120.       lX2 = lX
  121.       If lCtlWidth - lX <= lBMPWidth Then
  122.         lSrcWidth = lCtlWidth - lX
  123.       Else
  124.         lSrcWidth = lBMPWidth
  125.       End If
  126.     Else
  127.       lX2 = 0
  128.       lSrcOffset = Abs(lX)
  129.       lSrcWidth = lBMPWidth - lSrcOffset
  130.     End If
  131.   Else
  132.     If lX < lCtlWidth Then
  133.       If lX <= lBMPWidth Then
  134.         lX2 = 0
  135.         lSrcWidth = lX
  136.         lSrcOffset = lBMPWidth - lX
  137.       Else
  138.         lX2 = lX2 + BULB_WIDTH
  139.         lSrcWidth = lBMPWidth
  140.         lSrcOffset = 0
  141.       End If
  142.     Else
  143.       If lX > lBMPWidth Then
  144.         lX2 = lX2 + BULB_WIDTH
  145.         lSrcWidth = lBMPWidth
  146.       Else
  147.         lSrcOffset = lBMPWidth - lX
  148.         lSrcWidth = lCtlWidth
  149.       End If
  150.     End If
  151.   End If
  152.   
  153.   UserControl.PaintPicture picMsg.Picture, lX2, SRC_Y, , , _
  154.                            lSrcOffset, , lSrcWidth, , _
  155.                            vbSrcCopy
  156.   
  157.   If m_ScrollMode = R_to_L Then
  158.     If lSrcOffset + BULB_WIDTH = lBMPWidth Then
  159.       bRestart = True
  160.     Else
  161.       lX = lX - BULB_WIDTH
  162.     End If
  163.   Else
  164.     If lX2 + BULB_WIDTH = lCtlWidth Then
  165.       bRestart = True
  166.     Else
  167.       lX = lX + BULB_WIDTH
  168.     End If
  169.   End If
  170.   
  171. End Sub
  172.  
  173. Private Sub UserControl_Initialize()
  174.   InitBMPStruct
  175. End Sub
  176. Private Sub UserControl_InitProperties()
  177.   m_ScrollMode = m_def_ScrollMode
  178.   m_Text = m_def_Text
  179.   m_Scrolling = m_def_Scrolling
  180. End Sub
  181. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  182.   ScrollMode = PropBag.ReadProperty("ScrollMode", m_def_ScrollMode)
  183.   Text = PropBag.ReadProperty("Text", m_def_Text)
  184.   Scrolling = PropBag.ReadProperty("Scrolling", m_def_Scrolling)
  185. End Sub
  186. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  187.   Call PropBag.WriteProperty("ScrollMode", m_ScrollMode, m_def_ScrollMode)
  188.   Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
  189.   Call PropBag.WriteProperty("Scrolling", m_Scrolling, m_def_Scrolling)
  190. End Sub
  191.  
  192. Private Sub UserControl_Resize()
  193.   UserControl.Height = CTL_HEIGHT
  194.   lCtlWidth = UserControl.ScaleWidth - UserControl.ScaleWidth Mod 5
  195.   DrawBackground
  196. End Sub
  197.  
  198. Public Property Get Text() As String
  199. Attribute Text.VB_Description = "Text string to display on the marquee"
  200. Attribute Text.VB_ProcData.VB_Invoke_Property = ";Text"
  201.   Text = m_Text
  202. End Property
  203.  
  204. Public Property Let Text(ByVal New_Text As String)
  205.   m_Text = New_Text
  206.   PropertyChanged "Text"
  207.   If m_Scrolling Then
  208.     tAni.Enabled = False
  209.     bRestart = True
  210.     DrawBackground
  211.     BuildTheBmp (m_Text)
  212.     tAni.Enabled = True
  213.   Else
  214.     tAni.Enabled = False
  215.     bRestart = False
  216.   End If
  217.  
  218. End Property
  219.  
  220. Public Property Get Scrolling() As Boolean
  221. Attribute Scrolling.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
  222. Attribute Scrolling.VB_ProcData.VB_Invoke_Property = ";Behavior"
  223.   Scrolling = m_Scrolling
  224. End Property
  225.  
  226. Public Property Let Scrolling(ByVal bScrolling As Boolean)
  227.   
  228.   m_Scrolling = bScrolling
  229.   
  230.   PropertyChanged "Scrolling"
  231.   
  232.   If m_Scrolling Then
  233.     DrawBackground
  234.     BuildTheBmp (m_Text)
  235.     tAni.Enabled = True
  236.   Else
  237.     tAni.Enabled = False
  238.     bRestart = False
  239.   End If
  240.   
  241. End Property
  242.  
  243. Public Property Get ScrollMode() As ScrollModeValue
  244.   ScrollMode = m_ScrollMode
  245. End Property
  246.  
  247. Public Property Let ScrollMode(ByVal New_ScrollMode As ScrollModeValue)
  248.   m_ScrollMode = New_ScrollMode
  249.   PropertyChanged "ScrollMode"
  250.   If m_Scrolling Then
  251.     tAni.Enabled = False
  252.     bRestart = True
  253.     DrawBackground
  254.     BuildTheBmp (m_Text)
  255.     tAni.Enabled = True
  256.   Else
  257.     tAni.Enabled = False
  258.     bRestart = False
  259.   End If
  260.  
  261. End Property
  262.  
  263. Private Sub DrawBackground()
  264.   Dim lColX As Long
  265.   
  266.   With UserControl
  267.         .AutoRedraw = True
  268.     
  269.     For lColX = 0 To .ScaleWidth Step 5
  270.     
  271.       .PaintPicture picBlankCol.Picture, lColX, 0, _
  272.                     aCharSpace.Width, , _
  273.                     aCharSpace.Left, 0, _
  274.                     aCharSpace.Width
  275.     
  276.     Next lColX
  277.     
  278.     
  279.     .AutoRedraw = False
  280.     
  281.   End With
  282.   
  283. End Sub
  284.  
  285. Private Function BuildTheBmp(sText As String) As Long
  286.   Dim lChar     As Long
  287.   Dim lOffset   As Long
  288.   Dim lCharVal  As Long
  289.   Dim lCounter  As Long
  290.   Dim lMsgLength As Long
  291.   
  292.   
  293.   sText = UCase$(sText)
  294.   lMsgLength = Len(sText)
  295.   
  296.   With picMsg
  297.   
  298.       .AutoRedraw = True
  299.     
  300.       For lChar = 1 To lMsgLength
  301.       lCharVal = Asc(Mid$(sText, lChar, 1))
  302.       If lCharVal = 32 Then
  303.         For lCounter = 1 To 4
  304.           lOffset = lOffset + aCharSpace.Width
  305.         Next lCounter
  306.       
  307.       ElseIf lCharVal >= 65 And lCharVal <= 90 Then
  308.         lOffset = lOffset + aChars(lCharVal).Width
  309.       End If
  310.       
  311.     Next lChar
  312.     
  313.     
  314.     .Width = lOffset + aCharSpace.Width
  315.     
  316.     lOffset = 0
  317.     
  318.     For lChar = 1 To lMsgLength
  319.       
  320.     
  321.       lCharVal = Asc(Mid$(sText, lChar, 1))
  322.       
  323.       If lCharVal = 32 Then
  324.       
  325.         For lCounter = 1 To 4
  326.           .PaintPicture picCaps.Picture, lOffset, 0, _
  327.                         aCharSpace.Width, , _
  328.                         aCharSpace.Left, 0, _
  329.                         aCharSpace.Width
  330.           
  331.           lOffset = lOffset + aCharSpace.Width
  332.  
  333.         Next lCounter
  334.               
  335.       ElseIf lCharVal >= 65 And lCharVal <= 90 Then
  336.             
  337.                 
  338.         .PaintPicture picCaps.Picture, lOffset, 0, _
  339.                       aChars(lCharVal).Width, , _
  340.                       aChars(lCharVal).Left, 0, _
  341.                       aChars(lCharVal).Width
  342.                       
  343.         
  344.         lOffset = lOffset + aChars(lCharVal).Width
  345.       
  346.       Else
  347.         Debug.Print "Unsupported character entered - " & Mid$(sText, lChar, 1) & "ASCII = " & Asc(Mid$(sText, lChar, 1))
  348.       
  349.       End If
  350.       
  351.     Next lChar
  352.     
  353.     
  354.     .PaintPicture picCaps.Picture, lOffset, 0, _
  355.                   aCharSpace.Width, , _
  356.                   aCharSpace.Left, 0, _
  357.                   aCharSpace.Width
  358.                   
  359.     lOffset = lOffset + aCharSpace.Width
  360.     
  361.     
  362.     .AutoRedraw = False
  363.     
  364.     .Picture = picMsg.Image
  365.     
  366.   End With
  367.   
  368.     lBMPWidth = lOffset
  369.   
  370.   BuildTheBmp = 0
  371.   
  372.   bRestart = True
  373. End Function
  374.